home *** CD-ROM | disk | FTP | other *** search
/ ETO Development Tools 2 / ETO Development Tools 2.iso / Tools - Objects / MacApp / MacApp CD Release / MacApp 2.0.1 (Many Libraries) / Libraries / UObject.a < prev    next >
Encoding:
Text File  |  1990-10-25  |  6.1 KB  |  196 lines  |  [TEXT/MPS ]
  1. ;=============================================================================
  2. ; Object Pascal Library Routines
  3. ;
  4. ; Copyright © 1984-1990 Apple Computer, Inc.  All rights reserved.
  5. ;
  6. ; NOTE:
  7. ;    The optimizer redirects the following procedure name
  8. ;
  9. ;%_METHOD           becomes      %_JMPTOTRAP
  10. ;
  11.  
  12.                 Blanks        On
  13.                 String        AsIs
  14.                 Case        On
  15.  
  16.                 Print        Off
  17.                 Include     'Macros.a'
  18.                 Include     'Traps.a'
  19.  
  20.                 LOAD            'ProgStrucMacs.d'
  21.                 LOAD            'FlowCtlMacs.d'
  22.                 Print        On
  23.  
  24. ;---------------------------------------------------------------------------------------------------
  25. ;    tests testClass for being a member of the superClass
  26. ;        uses A0,A1,D0,D1
  27.  
  28.                 Seg         'MAObjectRes'
  29. EXPORT FUNCTION ISCLASSIDMEMBERCLASS(testClassID:W, superClassID:W):B
  30.     BEGIN
  31.             import PSUPERCLASSTABLE:DATA
  32.                 Move.W        superClassID(FP),D0     ; D0 := Test Class Number
  33.                 Beq.S        isFALSE                    ; Exit with FALSE if Test Class is NIL
  34.                 Move.W        testClassID(FP),D1        ; D1 := object Class number
  35.                 Beq.S        isFALSE                    ; Exit with FALSE if Test Class is NIL
  36.  
  37.                 Move.L        PSUPERCLASSTABLE(A5),A0    ; A0 := Superclass Table Handle
  38.                 Move.L        (A0),A0                 ; A0 := Superclass Table Pointer
  39.  
  40.                 Cmp.W        (A0),D0                    ; make sure class ID is in range
  41.                 Bge.S        isFALSE                
  42.                 Cmp.W        (A0),D1                    ; make sure class ID is in range
  43.                 Bge.S        isFALSE                
  44. INOB1
  45.                 Cmp.W        D1,D0                    ; Compare object's (or superclass') number against
  46.                                                     ; Test Class'
  47.                 Beq.S        isTRUE                    ; Exit with TRUE if we get a match
  48.                 Move.W        (A0,D1.W),D1            ; D1 := Superclass of D1
  49.                 Beq.S        isFALSE                    ; Zero means no superclass, so function returns false
  50.                 Bra.S        INOB1
  51.  
  52. isTRUE            Move.B         #1,ISCLASSIDMEMBERCLASS(FP)        ; Set return value to TRUE
  53.                 Bra.S        GoBack
  54.  
  55. isFALSE            Clr.B        ISCLASSIDMEMBERCLASS(FP)            ; Set return value to FALSE
  56. GoBack
  57.                 Return
  58.                 EndFunc
  59.  
  60.  
  61. ;---------------------------------------------------------------------------------------------------
  62.  
  63.                 Seg         'MAObjectRes'
  64. EXPORT PROCEDURE Dummy
  65.     BEGIN
  66.                 _Debugger
  67.  
  68.                 Return                        ; should never be reached
  69.                 ENDP
  70.  
  71. ;---------------------------------------------------------------------------------------------------
  72.  
  73.                 Seg         '%_MethTables'
  74. EXPORT PROCEDURE %_JMPTOTRAP
  75.     BEGIN x                                    ; suppress the LINK instruction
  76.             import Dummy
  77.                 Jmp         Dummy
  78.  
  79.                 Return                        ; should never be reached
  80.                 ENDP
  81.  
  82. ;---------------------------------------------------------------------------------------------------
  83.  
  84. ; Stack locations
  85. SelectorTableAddr    equ        0
  86. ActualReturnAddr    equ        SelectorTableAddr + 4
  87. RcvrHandleAddr        equ        ActualReturnAddr + 4
  88.  
  89. ;---------------------------------------------------------------------------------------------------
  90.  
  91.      If qDebug Then
  92.                 Seg         '%_MethTables'
  93. EXPORT PROCEDURE %_DISCIPLINEDISPATCH
  94.     BEGIN x                                    ; suppress the LINK instruction
  95.             import FAILNONOBJECT, Dummy, PDISCIPLINEMETHODCALLS:DATA
  96.                 Tst.B        PDISCIPLINEMETHODCALLS(A5)
  97.                 BZ.S        %_DISCIPLINEDISPATCH_PATCHPOINT
  98.                 Move.L        RcvrHandleAddr(SP), -(SP)    ;receiver handle for FailNonObject
  99.                 JSR         FAILNONOBJECT
  100.                 
  101.         Export %_DISCIPLINEDISPATCH_PATCHPOINT
  102. %_DISCIPLINEDISPATCH_PATCHPOINT:
  103.                 Jmp            Dummy            ; now dispatch
  104.  
  105.                 Return                        ; should never be reached
  106.                 ENDP
  107.       EndIf
  108.  
  109.  
  110. ;---------------------------------------------------------------------------------------------------
  111. ; PROCEDURE MethodDispatch ( 'uses nonstandard stack params ' );
  112. ;            (SP)        = selector table address    (first return address on stack)
  113. ;            4(SP)        = actual return address        (selector proc caller's return address)
  114. ;            8(SP)        = receiver                    (the object being dispatched for)
  115.  
  116. ; Uses only scratch registers: A0/A1/D0/D1/D2.  A5 must be correct.
  117.  
  118. ; Selector Proc Format
  119. ; --------------------
  120. ; JSR %_JmpToTrap
  121. ;   Selector Table
  122. ;   --------------
  123. ;   Number of repeating entries - 1
  124. ;   Cached ClassID
  125. ;   Cached Implementation address (A5 JT relative (16 bit))
  126. ;     Repeating Entries
  127. ;     -----------------
  128. ;     ClassID
  129. ;     Implementation address (A5 JT relative (16 bit))
  130. ;     .
  131. ;     .
  132. ;
  133.  
  134. ; Table locations
  135. NumberOfEntries        equ        0
  136. CacheClassID        equ        NumberOfEntries + 2
  137. CacheImplementation    equ        CacheClassID + 2
  138. FirstClassID        equ        CacheImplementation + 2
  139. FirstImplementation    equ        FirstClassID + 2
  140.  
  141. SizeOfEntry            equ        4
  142.  
  143.                 Seg         '%_MethTables'
  144. EXPORT PROCEDURE %_NEWMETHOD
  145.     BEGIN x,                                        ; suppress the link instruction
  146.             import PSUPERCLASSTABLE:DATA
  147.              import PDISPATCHERRORPROC:DATA
  148.                  Move.L     RcvrHandleAddr(SP),A1        ; A1 := receiver handle
  149.                 Move.L        (A1),A1                 ; A1 := receiver ptr
  150.                 Move.W        (A1),D0                 ; D0 := receiver's ClassID
  151.  
  152.                 Move.L        (SP)+,A0        ; A0 := Method table ptr
  153.                                             ; immediately follows selector
  154.                 Move.W        (A0)+,D1        ; D1 := number of implementations of method (-1)
  155.                 Cmp.W        (A0)+,D0         ; cached ClassID versus receiver ClassID
  156.                 Bne.S        search            ; Not Equal => must search table
  157.                 Move.W        (A0),A1            ; A1 := A5 relative offset to method
  158. CacheOut        Jmp         (A5,A1.W)        ; via Jump Table
  159. search
  160.                 Move.W        D0,-(A0)         ; cache the ClassID
  161.                 Move.L        A0,D2            ; D2 := ptr to ClassID cache
  162. loopa
  163.                 AddQ.L        #SizeOfEntry,A0    ; A0 := ptr to next ClassID in table
  164.                 Cmp.W        (A0),D0         ; next ClassID versus given ClassID
  165.                 DBcc        D1,loopa        ; fall through if (A0) unsigned <= D0
  166.                 Beq.S        found            ; Eq => found it
  167.                 Move.L        PSUPERCLASSTABLE(A5),A1    ; A1 := handle to Superclass table
  168.                 Move.L        (A1),A1             ; A1 := ptr to Superclass table
  169.                 Bra.S        doSuper         ; Get Superclass
  170. loopb
  171.                 AddQ.L        #SizeOfEntry,A0    ; A0 := ptr to next ClassID in table
  172. loop2
  173.                 Cmp.W        (A0),D0         ; next ClassID versus given ClassID
  174.                 DBcc        D1,loopb        ; fall through if (A0) unsigned <= D0
  175.                 Beq.S        found            ; Eq => found it
  176. doSuper
  177.                 Move.W        0(A1,D0.W),D0    ; D0 := SuperClassID of D0 (D0 is always even!)
  178.                 Bne.S        loop2            ; Not Equal => still worth searching
  179.  
  180.     ; Error condition: method not found
  181.                 Move.L        D2,A1            ; A1 := ptr to ClassID cache
  182.                 Clr.L        (A1)
  183.                 Move.L        PDISPATCHERRORPROC(A5),A1 ; ptr to error routine
  184. ErrorOut        Jmp         (A1)
  185.  
  186. found
  187.                 Move.L        D2,A1            ; A1 := ptr to ClassID cache
  188.                 Move.W        2(A0),A0         ; A0 := A5 relative offset to method
  189.                 Move.W        A0,2(A1)        ; stow Implementation in cache
  190. TableOut        Jmp         (A5,A0.W)        ; via Jump Table
  191.  
  192.                 Return                        ; should never be reached
  193.  
  194.                 End
  195.  
  196.